home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN1.LZH / GETCHAR.FOR < prev    next >
Text File  |  1988-02-08  |  4KB  |  130 lines
  1.       SUBROUTINE GETCHAR ( CH, ERROR )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **          GETCHAR          **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          GET CHARACTER
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD, CALIF  94035
  19. C*          (415) 694-5578
  20. C*
  21. C*     PURPOSE :
  22. C*          THIS ROUTINE WAITS UNTIL A SINGLE KEYSTROKE IS ENTERED.
  23. C*
  24. C*     INPUT ARGUMENTS :
  25. C*          NONE
  26. C*
  27. C*     OUTPUT ARGUMENTS :
  28. C*          CH    - THE ASCII INTEGER CHARACTER THAT WAS ENTERED.
  29. C*          ERROR - TRUE IF AN ERROR OCCURRED.
  30. C*
  31. C*     INTERNAL WORK AREAS :
  32. C*          NONE
  33. C*
  34. C*     COMMON BLOCKS :
  35. C*          NONE
  36. C*
  37. C*     FILE REFERENCES :
  38. C*          NONE
  39. C*
  40. C*     SUBPROGRAM REFERENCES :
  41. C*          SYS$ASSIGN, SUS$GET_EF, SYS$CLREF, SYS$QIOW
  42. C*
  43. C*     ERROR PROCESSING :
  44. C*          PASSES ALONG THE ERROR CODES FROM THE SYSTEM SERVICES
  45. C*
  46. C*     TRANSPORTABILITY LIMITATIONS :
  47. C*          NOT TRANSPORTABLE
  48. C*
  49. C*     ASSUMPTIONS AND RESTRICTIONS :
  50. C*          THIS ROUTINE WORKS ONLY TO 'TT:'
  51. C*          THE USER SHOULD ALWAYS CHECK THE VALUE OF 'ERROR' IN THE
  52. C*                 CALLING PROGRAM.
  53. C*
  54. C*     LANGUAGE AND COMPILER :
  55. C*          ANSI FORTRAN 77
  56. C*
  57. C*     VERSION AND DATE :
  58. C*          VERSION I.0     28-FEB-85
  59. C*
  60. C*     CHANGE HISTORY :
  61. C*          28-FEB-85    INITIAL VERSION
  62. C*
  63. C***********************************************************************
  64. C*
  65.       IMPLICIT INTEGER (A-Z)
  66.       EXTERNAL SS$_NORMAL, IO$_TTYREADALL, IO$M_TIMED, IO$M_NOECHO
  67.       EXTERNAL SS$_WASCLR, SS$_WASSET
  68.       SAVE INIT, TERM_CHAN, KEYBOARD_EF, READ_FUNC
  69.       LOGICAL ERROR, INIT
  70.       BYTE CH
  71.       DATA NO_TIME /999/, INIT/.FALSE./
  72. C
  73. C... ERROR MASKS
  74. C
  75.       INTEGER*2 IOSB(4)
  76.       DATA STATUS /1/, BYTECNT /2/, TERMINATOR /3/, TERMINSIZ /4/
  77. C
  78. C... TERMINATOR TABLE WITH NO TERMINATORS
  79. C
  80.       INTEGER*4 NO_TERMINATORS(2), TERM_MASK(8)
  81.       DATA NO_TERMINATORS /32,0/
  82.       DATA TERM_MASK /'00000000'X,'00000000'X,'00000000'X,'00000000'X,
  83.      $                '00000000'X,'00000000'X,'00000000'X,'00000000'X/
  84.       NO_TERMINATORS(2) = %LOC(TERM_MASK)
  85. C
  86.       ERROR = .FALSE.
  87.       IF (.NOT. INIT) THEN
  88. C
  89. C ASSIGN AN IO CHANNEL FOR TT:
  90. C
  91.          ISTAT = SYS$ASSIGN ('TT', TERM_CHAN,,)
  92.          IF (ISTAT .NE. %LOC(SS$_NORMAL)) THEN
  93.             ERROR = .TRUE.
  94.             RETURN
  95.          ENDIF
  96. C
  97. C ALLOCATE AN EVENT FLAG AND CLEAR IT
  98. C
  99.          ISTAT = LIB$GET_EF(KEYBOARD_EF)
  100.          IF (ISTAT .NE. %LOC(SS$_NORMAL)) THEN
  101.             ERROR = .TRUE.
  102.             RETURN
  103.          ENDIF
  104.          ISTAT = SYS$CLREF (%VAL(KEYBOARD_EF))
  105.          IF (ISTAT .NE. %LOC(SS$_WASCLR)  .AND.
  106.      $       ISTAT .NE. %LOC(SS$_WASSET)) THEN
  107.             ERROR = .TRUE.
  108.             RETURN
  109.          ENDIF
  110.          READ_FUNC = %LOC(IO$_TTYREADALL) .OR. %LOC(IO$M_TIMED) .OR.
  111.      $               %LOC(IO$M_NOECHO)
  112.          INIT = .TRUE.
  113.       ENDIF
  114. C
  115. C INITIATE A SINGLE CHARACTER READ
  116. C
  117.       ISTAT = SYS$QIOW (%VAL(KEYBOARD_EF), %VAL(TERM_CHAN),
  118.      $                  %VAL(READ_FUNC), IOSB,,, CH, %VAL(1),
  119.      $                  %VAL(NO_TIME), NO_TERMINATORS,,)
  120. C
  121. C IGNORE ANY ERRORS
  122. C
  123.       IF (IOSB(STATUS) .NE. %LOC(SS$_NORMAL) .OR.
  124.      $    IOSB(BYTECNT) .NE. 1) CH = 0
  125.       RETURN
  126.       END
  127. C
  128. C---END GETCHAR
  129. C
  130.